home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / iteration.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  8KB  |  425 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     iteration.c
  10.  
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. Floop(form)
  16. object form;
  17. {
  18.     object x;
  19.     object *oldlex = lex_env;
  20.     object id;
  21.     object *top;
  22.  
  23.     make_nil_block();
  24.  
  25.     if (nlj_active) {
  26.         nlj_active = FALSE;
  27.         frs_pop();
  28.         lex_env = oldlex;
  29.         return;
  30.     }
  31.  
  32.     top = vs_top;
  33.  
  34.     for(x = form; !endp(x); x = MMcdr(x)) {
  35.         vs_top = top;
  36.         eval(MMcar(x));
  37.     }
  38. LOOP:
  39.     /*  Just !endp(x) is replaced by x != Cnil.  */
  40.     for(x = form;  x != Cnil;  x = MMcdr(x)) {
  41.         vs_top = top;
  42.         eval(MMcar(x));
  43.     }
  44.     goto LOOP;
  45. }
  46.  
  47. /*
  48.     use of VS in Fdo and FdoA:
  49.             |    |
  50.          lex_env ->    | lex1    |
  51.             | lex2    |
  52.             | lex3    |
  53.          start ->    |-------|    where each bt is a bind_temp:
  54.             |  bt1    |
  55.             |-------|    |  var    | -- name of DO variable
  56.                 :        |  spp    | -- T if special
  57.             |-------|    | init    |
  58.             |  btn    |    |  aux    | -- step-form or var (if no
  59.             |-------|             step-form is given)
  60.          end ->    | body    |
  61.          old_top->    |-------|    If 'spp' != T, it is NIL during
  62.                     initialization, and is the pointer to
  63.                     (var value) in lexical environment
  64.                     during the main loop.
  65. */
  66.  
  67. do_var_list(var_list)
  68. object var_list;
  69. {
  70.     object is, x, y;
  71.  
  72.     for (is = var_list;  !endp(is);  is = MMcdr(is)) {
  73.         x = MMcar(is);
  74.         if (type_of(x) != t_cons)
  75.             FEinvalid_form("The index, ~S, is illegal.", x);
  76.         y = MMcar(x);
  77.         check_var(y);
  78.         vs_push(y);
  79.         vs_push(Cnil);
  80.         if (endp(MMcdr(x))) {
  81.             vs_push(Cnil);
  82.             vs_push(y);
  83.         } else {
  84.             x = MMcdr(x);
  85.             vs_push(MMcar(x));
  86.             if (endp(MMcdr(x)))
  87.                 vs_push(y);
  88.             else {
  89.                 x = MMcdr(x);
  90.                 vs_push(MMcar(x));
  91.                 if (!endp(MMcdr(x)))
  92.                     FEerror("Too many forms to the index ~S.",
  93.                         1, y);
  94.             }
  95.         }
  96.     }
  97. }
  98.  
  99. Fdo(arg)
  100. object arg;
  101. {
  102.     object *oldlex = lex_env;
  103.     object *old_top;
  104.     struct bind_temp *start, *end, *bt;
  105.     object end_test, body, result;
  106.     bds_ptr old_bds_top = bds_top;
  107.  
  108.     if (endp(arg) || endp(MMcdr(arg)))
  109.         FEtoo_few_argumentsF(arg);
  110.     if (endp(MMcadr(arg)))
  111.         FEinvalid_form("The DO end-test, ~S, is illegal.",
  112.                 MMcadr(arg));
  113.  
  114.     end_test = MMcaadr(arg);
  115.     result = MMcdadr(arg);
  116.  
  117.     make_nil_block();
  118.  
  119.     if (nlj_active) {
  120.         nlj_active = FALSE;
  121.         goto END;
  122.     }
  123.  
  124.     start = (struct bind_temp *) vs_top;
  125.  
  126.     do_var_list(MMcar(arg));
  127.     end = (struct bind_temp *)vs_top;
  128.     body = let_bind(MMcddr(arg), start, end);
  129.     vs_push(body);
  130.  
  131.     for (bt = start;  bt < end;  bt++)
  132.         if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
  133.             bt->bt_spp = Ct;
  134.         else if (bt->bt_spp == Cnil)
  135.             bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
  136.  
  137.     old_top = vs_top;
  138.  
  139. LOOP:    /* the main loop */
  140.     vs_top = old_top;
  141.     eval(end_test);
  142.     if (vs_base[0] != Cnil) {
  143.         /* RESULT evaluation */
  144.         if (endp(result)) {
  145.             vs_base = vs_top = old_top;
  146.             vs_push(Cnil);
  147.         } else
  148.             do {
  149.                 vs_top = old_top;
  150.                 eval(MMcar(result));
  151.                 result = MMcdr(result);
  152.             } while (!endp(result));
  153.         goto END;
  154.     }
  155.  
  156.     vs_top = old_top;
  157.  
  158.     Ftagbody(body);
  159.  
  160.     /* next step */
  161.     for (bt = start;  bt<end;  bt++) {
  162.         if (bt->bt_aux != bt->bt_var) {
  163.             eval_assign(bt->bt_init, bt->bt_aux);
  164.         }
  165.     }
  166.     for (bt = start;  bt<end;  bt++) {
  167.         if (bt->bt_aux != bt->bt_var)
  168.             if (bt->bt_spp == Ct)
  169.                 bt->bt_var->s.s_dbind = bt->bt_init;
  170.             else
  171.                 MMcadr(bt->bt_spp) = bt->bt_init;
  172.     }
  173.     goto LOOP;
  174.  
  175. END:
  176.     bds_unwind(old_bds_top);
  177.     frs_pop();
  178.     lex_env = oldlex;
  179. }
  180.  
  181. FdoA(arg)
  182. object arg;
  183. {
  184.     object *oldlex = lex_env;
  185.     object *old_top;
  186.     struct bind_temp *start, *end, *bt;
  187.     object end_test, body, result;
  188.     bds_ptr old_bds_top = bds_top;
  189.  
  190.     if (endp(arg) || endp(MMcdr(arg)))
  191.         FEtoo_few_argumentsF(arg);
  192.     if (endp(MMcadr(arg)))
  193.         FEinvalid_form("The DO* end-test, ~S, is illegal.",
  194.                 MMcadr(arg));
  195.  
  196.     end_test = MMcaadr(arg);
  197.     result = MMcdadr(arg);
  198.  
  199.     make_nil_block();
  200.  
  201.     if (nlj_active) {
  202.         nlj_active = FALSE;
  203.         goto END;
  204.     }
  205.  
  206.     start = (struct bind_temp *)vs_top;
  207.     do_var_list(MMcar(arg));
  208.     end = (struct bind_temp *)vs_top;
  209.     body = letA_bind(MMcddr(arg), start, end);
  210.     vs_push(body);
  211.  
  212.     for (bt = start;  bt < end;  bt++)
  213.         if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
  214.             bt->bt_spp = Ct;
  215.         else if (bt->bt_spp == Cnil)
  216.             bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
  217.  
  218.     old_top = vs_top;
  219.  
  220. LOOP:    /* the main loop */
  221.     eval(end_test);
  222.     if (vs_base[0] != Cnil) {
  223.         /* RESULT evaluation */
  224.         if (endp(result)) {
  225.             vs_base = vs_top = old_top;
  226.             vs_push(Cnil);
  227.         } else
  228.             do {
  229.                 vs_top = old_top;
  230.                 eval(MMcar(result));
  231.                 result = MMcdr(result);
  232.             } while (!endp(result));
  233.         goto END;
  234.     }
  235.  
  236.     vs_top = old_top;
  237.  
  238.     Ftagbody(body);
  239.  
  240.     /* next step */
  241.     for (bt = start;  bt < end;  bt++)
  242.         if (bt->bt_aux != bt->bt_var) {
  243.             if (bt->bt_spp == Ct) {
  244.                 eval_assign(bt->bt_var->s.s_dbind, bt->bt_aux);
  245.             } else {
  246.                 eval_assign(MMcadr(bt->bt_spp), bt->bt_aux);
  247.             }
  248.         }
  249.     goto LOOP;
  250.  
  251. END:
  252.     bds_unwind(old_bds_top);
  253.     frs_pop();
  254.     lex_env = oldlex;
  255. }
  256.  
  257. Fdolist(arg)
  258. object arg;
  259. {
  260.     object *oldlex = lex_env;
  261.     object *old_top;
  262.     struct bind_temp *start;
  263.     object x, listform, result, body;
  264.     bds_ptr old_bds_top = bds_top;
  265.  
  266.     if (endp(arg))
  267.         FEtoo_few_argumentsF(arg);
  268.  
  269.     x = MMcar(arg);
  270.     if (endp(x))
  271.         FEerror("No variable.", 0);
  272.     start = (struct bind_temp *)vs_top;
  273.     vs_push(MMcar(x));
  274.     vs_push(Cnil);
  275.     vs_push(Cnil);
  276.     vs_push(Cnil);
  277.     x = MMcdr(x);
  278.     if (endp(x))
  279.         FEerror("No listform.", 0);
  280.     listform = MMcar(x);
  281.     x = MMcdr(x);
  282.     if (endp(x))
  283.         result = Cnil;
  284.     else {
  285.         result = MMcar(x);
  286.         if (!endp(MMcdr(x)))
  287.             FEerror("Too many resultforms.", 0);
  288.     }
  289.  
  290.     make_nil_block();
  291.  
  292.     if (nlj_active) {
  293.         nlj_active = FALSE;
  294.         goto END;
  295.     }
  296.  
  297.     eval_assign(start->bt_init, listform);
  298.     body = find_special(MMcdr(arg), start, start+1);
  299.     vs_push(body);
  300.     bind_var(start->bt_var, Cnil, start->bt_spp);
  301.     if ((enum stype)start->bt_var->s.s_stype != stp_ordinary)
  302.         start->bt_spp = Ct;
  303.     else if (start->bt_spp == Cnil)
  304.         start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
  305.  
  306.     old_top = vs_top;
  307.  
  308. LOOP:    /* the main loop */
  309.     if (endp(start->bt_init)) {
  310.         if (start->bt_spp == Ct)
  311.             start->bt_var->s.s_dbind = Cnil;
  312.         else
  313.             MMcadr(start->bt_spp) = Cnil;
  314.         eval(result);
  315.         goto END;
  316.     }
  317.  
  318.     if (start->bt_spp == Ct)
  319.         start->bt_var->s.s_dbind = MMcar(start->bt_init);
  320.     else
  321.         MMcadr(start->bt_spp) = MMcar(start->bt_init);
  322.     start->bt_init = MMcdr(start->bt_init);
  323.  
  324.     vs_top = old_top;
  325.  
  326.     Ftagbody(body);
  327.  
  328.     goto LOOP;
  329.  
  330. END:
  331.     bds_unwind(old_bds_top);
  332.     frs_pop();
  333.     lex_env = oldlex;
  334. }
  335.  
  336. Fdotimes(arg)
  337. object arg;
  338. {
  339.     object *oldlex = lex_env;
  340.     object *old_top;
  341.     struct bind_temp *start;
  342.     object x, countform, result, body;
  343.     bds_ptr old_bds_top = bds_top;
  344.  
  345.     if (endp(arg))
  346.         FEtoo_few_argumentsF(arg);
  347.  
  348.     x = MMcar(arg);
  349.     if (endp(x))
  350.         FEerror("No variable.", 0);
  351.     start = (struct bind_temp *)vs_top;
  352.     vs_push(MMcar(x));
  353.     vs_push(Cnil);
  354.     vs_push(Cnil);
  355.     vs_push(Cnil);
  356.     x = MMcdr(x);
  357.     if (endp(x))
  358.         FEerror("No countform.", 0);
  359.     countform = MMcar(x);
  360.     x = MMcdr(x);
  361.     if (endp(x))
  362.         result = Cnil;
  363.     else {
  364.         result = MMcar(x);
  365.         if (!endp(MMcdr(x)))
  366.             FEerror("Too many resultforms.", 0);
  367.     }
  368.  
  369.     make_nil_block();
  370.  
  371.     if (nlj_active) {
  372.         nlj_active = FALSE;
  373.         goto END;
  374.     }
  375.  
  376.     eval_assign(start->bt_init, countform);
  377.     if (type_of(start->bt_init) != t_fixnum &&
  378.         type_of(start->bt_init) != t_bignum)
  379.         FEwrong_type_argument(Sinteger, start->bt_init);
  380.     body = find_special(MMcdr(arg), start, start+1);
  381.     vs_push(body);
  382.     bind_var(start->bt_var, make_fixnum(0), start->bt_spp);
  383.     if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) {
  384.         start->bt_spp = Ct;
  385.         x = start->bt_var->s.s_dbind;
  386.     } else if (start->bt_spp == Cnil) {
  387.         start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
  388.         x = MMcadr(start->bt_spp);
  389.     } else
  390.         x = start->bt_var->s.s_dbind;
  391.  
  392.     old_top = vs_top;
  393.  
  394. LOOP:    /* the main loop */
  395.     if (number_compare(x, start->bt_init) >= 0) {
  396.         eval(result);
  397.         goto END;
  398.     }
  399.  
  400.     vs_top = old_top;
  401.  
  402.     Ftagbody(body);
  403.  
  404.     if (start->bt_spp == Ct)
  405.         x = start->bt_var->s.s_dbind = one_plus(x);
  406.     else
  407.         x = MMcadr(start->bt_spp) = one_plus(x);
  408.  
  409.     goto LOOP;
  410.  
  411. END:
  412.     bds_unwind(old_bds_top);
  413.     frs_pop();
  414.     lex_env = oldlex;
  415. }
  416.  
  417. init_iteration()
  418. {
  419.     make_special_form("LOOP", Floop);
  420.     make_special_form("DO", Fdo);
  421.     make_special_form("DO*", FdoA);
  422.     make_special_form("DOLIST", Fdolist);
  423.     make_special_form("DOTIMES", Fdotimes);
  424. }
  425.